home *** CD-ROM | disk | FTP | other *** search
/ Aminet 24 / Aminet 24 (1998)(GTI - Schatztruhe)[!][Apr 1998].iso / Aminet / dev / c / AmiVoGL_MDEV.lha / examples / flcube.for < prev    next >
Text File  |  1991-06-07  |  3KB  |  179 lines
  1.  
  2.     program flcube
  3.  
  4. $INCLUDE: 'fvogl.h'
  5. $INCLUDE: 'fvodevic.h'
  6.  
  7.     integer x, y, but
  8.     integer *2 val
  9.  
  10.     parameter(TRANS = 20.0, SC = 0.1)
  11.  
  12.     call prefsi(500, 500)
  13.  
  14.     call winope('flcube', 6)
  15.  
  16.     call unqdev(INPUTC)
  17.     call qdevic(SKEY)
  18.     call qdevic(XKEY)
  19.     call qdevic(YKEY)
  20.     call qdevic(ZKEY)
  21.     call qdevic(EQUALK)
  22.     call qdevic(MINUSK)
  23.     call qdevic(ESCKEY)
  24.     call qdevic(QKEY)
  25.  
  26.     call window(-800.0, 800.0, -800.0, 800.0, -800.0, 800.0)
  27.     call lookat(0.0, 0.0, 1500.0, 0.0, 0.0, 0.0, 0)
  28.  
  29.     tdir = TRANS
  30.     scal = SC
  31.  
  32.     nplanes = getpla()
  33.     if (nplanes .eq. 1) call makecu(0)
  34.  
  35.     call makecu(1)
  36.  
  37.     call backfa(.true.)
  38. c
  39. c Setup drawing into the backbuffer....
  40. c
  41.     call double
  42.     call gconfi
  43.  
  44. 1    continue
  45.         x = 500 - getval(MOUSEX)
  46.         y = 500 - getval(MOUSEY)
  47.         x = x * 3
  48.         y = y * 3
  49.         call pushma
  50.             call rotate(x, 'y')
  51.             call rotate(y, 'x')
  52.             call color(BLACK)
  53.             call clear
  54.             call callob(3)
  55.             if (nplanes .eq. 1) call callob(2)
  56.         call popmat
  57.         call swapbu
  58.  
  59.         
  60.         if (qtest()) then
  61.             but = qread(val)
  62.             if (but .eq. XKEY) then
  63.                 call transl(tdir, 0.0, 0.0)
  64.             else if (but .eq. YKEY) then
  65.                 call transl(0.0, tdir, 0.0)
  66.             else if (but .eq. ZKEY) then
  67.                 call transl(0.0, 0.0, tdir)
  68.             else if (but .eq. SKEY) then
  69.                 call scale(scal, scal, scal)
  70.             else if (but .eq. MINUSK) then
  71.                 tdir = -tdir
  72.             
  73.                 if (scal .lt. 1.0) then
  74.                     scal = 1.0 + SC
  75.                 else
  76.                     scal = 1.0 - SC
  77.                 end if
  78.  
  79.             else if (but .eq. EQUALK) then
  80. c
  81. c                we are pretending it's a '+' key
  82. c                we are supposed to see if the shift key is
  83. c                also down - but who could be bothered!
  84. c
  85.                 tdir = TRANS
  86.             else if (but .eq. QKEY .or. but .eq. ESCKEY) then
  87.                 call gexit
  88.                 stop
  89.             end if
  90. c
  91. c            Swallow the UP event as well...
  92. c
  93.             but = qread(val)
  94.         end if
  95.     goto 1
  96.     end
  97.  
  98.     subroutine makecu(fill)
  99. $INCLUDE: 'fvogl.h'
  100.     integer    fill
  101.  
  102.     call makeob(fill + 2)
  103.         if (fill .ne. 0) then
  104.             call polymo(PYM_FI)
  105.         else
  106.             call polymo(PYM_LI)
  107.             call color(BLACK)
  108.         end if
  109.  
  110.         call pushma
  111.             call transl(0.0, 0.0, 200.0)
  112.             if (fill .ne. 0) then 
  113.                 call color(RED)
  114.                 call rectf(-200.0, -200.0, 200.0, 200.0)
  115.             else
  116.                 call rect(-200.0, -200.0, 200.0, 200.0)
  117.             end if
  118.         call popmat
  119.  
  120.         call pushma
  121.             call transl(200.0, 0.0, 0.0)
  122.             call rotate(900, 'y')
  123.             if (fill .ne. 0) then
  124.                 call color(GREEN)
  125.                 call rectf(-200.0, -200.0, 200.0, 200.0)
  126.             else
  127.                 call rect(-200.0, -200.0, 200.0, 200.0)
  128.             end if
  129.         call popmat
  130.  
  131.         call pushma
  132.             call transl(0.0, 0.0, -200.0)
  133.             call rotate(1800, 'y')
  134.             if (fill .ne. 0) then
  135.                 call color(BLUE)
  136.                 call rectf(-200.0, -200.0, 200.0, 200.0)
  137.             else
  138.                 call rect(-200.0, -200.0, 200.0, 200.0)
  139.             end if
  140.         call popmat
  141.  
  142.         call pushma
  143.             call transl(-200.0, 0.0, 0.0)
  144.             call rotate(-900, 'y')
  145.             if (fill .ne. 0) then
  146.                 call color(CYAN)
  147.                 call rectf(-200.0, -200.0, 200.0, 200.0)
  148.             else
  149.                 call rect(-200.0, -200.0, 200.0, 200.0)
  150.             end if
  151.         call popmat
  152.  
  153.         call pushma
  154.             call transl(0.0, 200.0, 0.0)
  155.             call rotate(-900, 'x')
  156.             if (fill .ne. 0) then
  157.                 call color(MAGENT)
  158.                 call rectf(-200.0, -200.0, 200.0, 200.0)
  159.             else
  160.                 call rect(-200.0, -200.0, 200.0, 200.0)
  161.             end if
  162.         call popmat
  163.  
  164.         call pushma
  165.             call transl(0.0, -200.0, 0.0)
  166.             call rotate(900, 'x')
  167.             if (fill .ne. 0) then
  168.                 call color(YELLOW)
  169.                 call rectf(-200.0, -200.0, 200.0, 200.0)
  170.             else
  171.                 call rect(-200.0, -200.0, 200.0, 200.0)
  172.             end if
  173.         call popmat
  174.  
  175.     call closeo
  176.  
  177.     return
  178.     end
  179.